PC go! 2008 April/PCgo 2008-04 (DVD).iso/interface/contents/demoversionen_3846/13664/files/Data1.cab/mmerge.bas

BASIC Source File | 2001-10-16 | 6.5 KB | 252 lines

Attribute VB_Name = "mMerge"
'******************************************************************'
'*                                                                *'
'*                      TurboCAD for Windows                      *'
'*                   Copyright (c) 1993 - 2001                    *'
'*             International Microcomputer Software, Inc.         *'
'*                            (IMSI)                              *'
'*                      All rights reserved.                      *'
'*                                                                *'
'******************************************************************'

Option Explicit

Dim gxLStylesSrc  As LineStyles
Dim gxBStylesSrc  As BrushStyles
Dim gxLyrsSrc     As Layers
Dim gxBlocksSrc   As Blocks
Dim gxDwgSrc As Drawing

Dim gxLStylesTrg  As LineStyles
Dim gxBStylesTrg  As BrushStyles
Dim gxLyrsTrg     As Layers
Dim gxBlocksTrg   As Blocks
Dim gxDwgTrg As Drawing

Private Function MergeLStyle(gxLStyleSrc As LineStyle) As LineStyle
    Dim strName As String
    Dim varDashes As Variant

    Dim gxLStyle As LineStyle

    strName = gxLStyleSrc.Name
    On Error GoTo AddLStyle
    Set gxLStyle = gxLStylesTrg.Item(strName)
OK:
    Set MergeLStyle = gxLStyle
    Exit Function
AddLStyle:
    On Error GoTo ErrHandler
    gxLStyleSrc.GetDashes varDashes
    Set gxLStyle = gxLStylesTrg.Add(strName, varDashes)
    GoTo OK
ErrHandler:
    If Err.Description <> "" Then
        MsgBox Err.Description
    End If
End Function

Private Function MergeBStyle(gxBStyleSrc As BrushStyle) As BrushStyle
    Dim strName As String

    Dim gxBStyle As BrushStyle

    strName = gxBStyleSrc.Name
    On Error GoTo AddBStyle
    Set gxBStyle = gxBStylesTrg.Item(strName)
OK:
    Set MergeBStyle = gxBStyle
    Exit Function
AddBStyle:
    On Error GoTo ErrHandler
    ' sorry but it is impossible for now to add brush style with
    ' custom hatch style or patterns or etc
    Set gxBStyle = gxBStylesTrg("SOLID")
    GoTo OK
ErrHandler:
    If Err.Description <> "" Then
        MsgBox Err.Description
    End If
End Function

Private Function MergeLayer(gxLyrSrc As Layer) As Layer

    Dim strName As String
    Dim gxLStyle As LineStyle
    Dim gxBStyle As BrushStyle

    Dim gxLyr As Layer

    On Error Resume Next
    Set gxLStyle = MergeLStyle(gxLyrSrc.LineStyle)
    Set gxBStyle = MergeBStyle(gxLyrSrc.BrushStyle)

    strName = gxLyrSrc.Name
    On Error GoTo AddLyr
    Set gxLyr = gxLyrsTrg.Item(strName)
    Set gxLyr.LineStyle = gxLStyle
    Set gxLyr.BrushStyle = gxBStyle
OK:
    Set MergeLayer = gxLyr
    Exit Function
AddLyr:
    On Error GoTo ErrHandler

    Set gxLyr = gxLyrsTrg.Add(strName _
                             , gxLyrSrc.Visible _
                             , gxLyrSrc.Editable _
                             , gxLyrSrc.Frozen _
                             , gxLyrSrc.Color _
                             , gxLStyle _
                             , gxBStyle _
                             , _
                             , gxLyrSrc.ZOrder)

    GoTo OK

ErrHandler:
    If Err.Description <> "" Then
        MsgBox Err.Description
    End If

End Function

Private Function MergeBlock(gxBlkSrc As Block) As Block

    Dim gxBlkTrg As Block
    Dim gxVrtAnchor As Vertex
    Dim gxGrSrc As Graphic
    Dim gxGrsSrc As Graphics
    Dim gxGrTrg As Graphic
    Dim strName As String

    Dim varX As Variant
    Dim varY As Variant
    Dim varZ As Variant

    Dim varTileModeOld As Variant

    varX = 0
    varY = 0
    varZ = 0

    strName = gxBlkSrc.Name
    On Error GoTo AddBlk1
    Set gxBlkTrg = gxBlocksTrg.Item(strName)
OK:
    Set MergeBlock = gxBlkTrg
    Exit Function

AddBlk1:
    varTileModeOld = gxDwgTrg.Properties("TileMode")
    gxDwgTrg.Properties("TileMode") = 1

    On Error GoTo AddBlk2
    Set gxVrtAnchor = gxBlkSrc.Anchor
    On Error GoTo ErrHandler

    varX = gxVrtAnchor.X
    varY = gxVrtAnchor.Y
    varZ = gxVrtAnchor.Z

AddBlk2:
    On Error GoTo ErrHandler

    Set gxGrsSrc = gxBlkSrc.Graphics
    Set gxGrSrc = gxGrsSrc
    Set gxGrTrg = gxGrSrc.Duplicate()
    gxDwgTrg.Graphics.AddGraphic gxGrTrg

    CorrectGraphic gxGrTrg, gxGrSrc

    gxBlocksTrg.Add strName, gxGrTrg, varX, varY, varZ
    gxGrTrg.Delete

    gxDwgTrg.Properties("TileMode") = varTileModeOld
    GoTo OK
ErrHandler:
    If Err.Description <> "" Then
        MsgBox Err.Description
    End If

End Function

Private Sub CorrectGraphic(gxGr As Graphic, gxGrSrc As Graphic)

    Dim gxGrChild   As Graphic
    Dim gxGrs       As Graphics
    Dim gxBlk       As Block
    Dim gxLStyle As LineStyle
    Dim gxBStyle As BrushStyle
    Dim gxLyr As Layer
    Dim ind As Long

    On Error Resume Next

    If (gxGr.Builtin) Then
        ind = 0
        Set gxGrs = gxGr.Graphics
        For Each gxGrChild In gxGrs
            CorrectGraphic gxGrChild, gxGrSrc.Graphics(ind)
            ind = ind + 1
        Next gxGrChild
    End If

    Set gxLyr = MergeLayer(gxGrSrc.Layer)
    Set gxLStyle = MergeLStyle(gxGrSrc.LineStyle)
    Set gxBStyle = MergeBStyle(gxGrSrc.BrushStyle)

    If (gxGr.TypeByValue = imsiInsert) Then
        Set gxBlk = MergeBlock(gxGrSrc.Block)
        gxGr.Block = gxBlk
    End If

    gxGr.Layer = gxLyr
    gxGr.LineStyle = gxLStyle
    gxGr.BrushStyle = gxBStyle

End Sub

Public Sub MergeGraphic(gxGr As Graphic, gxDwgFrom As Drawing, gxDwgTo As Drawing)

    Dim gxGrTrg As Graphic

    Set gxDwgSrc = gxDwgFrom
    Set gxDwgTrg = gxDwgTo

    On Error GoTo Done
    Set gxLStylesSrc = gxDwgSrc.LineStyles
    Set gxBStylesSrc = gxDwgSrc.BrushStyles
    Set gxLyrsSrc = gxDwgSrc.Layers
    Set gxBlocksSrc = gxDwgSrc.Blocks

    Set gxLStylesTrg = gxDwgTrg.LineStyles
    Set gxBStylesTrg = gxDwgTrg.BrushStyles
    Set gxLyrsTrg = gxDwgTrg.Layers
    Set gxBlocksTrg = gxDwgTrg.Blocks

    Set gxGrTrg = gxDwgSrc.Graphics.Remove(gxGr.Duplicate().Index)
    gxGrTrg.ID = 0
    gxDwgTrg.Graphics.AddGraphic gxGrTrg

    CorrectGraphic gxGrTrg, gxGr

Done:
    Set gxLStylesSrc = Nothing
    Set gxBStylesSrc = Nothing
    Set gxLyrsSrc = Nothing
    Set gxBlocksSrc = Nothing

    Set gxDwgSrc = Nothing

    Set gxLStylesTrg = Nothing
    Set gxBStylesTrg = Nothing
    Set gxLyrsTrg = Nothing
    Set gxBlocksTrg = Nothing

    Set gxDwgTrg = Nothing


End Sub